;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; General utilities
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (default-prompter port)
  (let ((state (input-port-read-state port)))
    (if (char=? state #\Newline)
        ""
        (string-append (if (char=? state #\Space)
                           "#|monos:"
                           (string-append "#|" (make-string 1 state) "---:"))
                       (number->string (input-port-line-number port))
                       "|# "))))


(define (map-to-java-list func l :: <java.util.List>)
   (letrec ((length (- (java.util.List:size l) 1))
            (apply-n
               (lambda (n)
                  (if (= n length)
                      (list (func (java.util.List:get l n)))
                      (cons (func (java.util.List:get l n)) (apply-n (+ n 1))) ))) )
      (if (= length 0)
          '()
          (apply-n 0)) ))

(define (for-each-java-list func l :: <java.util.List>)
   (let ((length (java.util.List:size l)) )
      (do ((n 0 (+ n 1)))
          ((= n length) #t)
          (func (java.util.List:get l n)) )))

(define (java-list->list l :: <java.util.List>)
   (map-to-java-list (lambda (x) x) l))

(define (make-list length obj)
      (letrec ((self (lambda (length obj)
                 (if (= length 1)
                   (list obj)
                   (cons obj (self (- length 1) obj)) ))) )
         (self length obj)) )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Lex Orders
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax lex-order
   (syntax-rules ()
      ((lex-order var ...)
       (list->lex-order `(var ...)) ) ))

(define (dimension order)
   (java.util.List:size order)) 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Lex Ordered Lists
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax lexed-list
   (syntax-rules (*lex-order*)
      ((lexed-list i ...)
       (construct-lexed-list *lex-order* i ...) ) ))

(define-syntax lexed-list-with-order
   (syntax-rules (*lex-order*)
      ((lexed-list-with-order order)
          (construct-lexed-list order))
      ((lexed-list-with-order order i ...)
       (fluid-let ((*lex-order* order) )
          (construct-lexed-list *lex-order* i ...) )) ))

(define (construct-lexed-list order . l)
   (let ((i (com.milowski.monos.monomial.LexOrderedList:new order)))
       (for-each (lambda (x) (java.util.List:add i x)) l) 
       i))

(define (lexed-list-for-each func l :: <com.milowski.monos.monomial.LexOrderedList>)
   (for-each-java-list func l))

(define (lex-order-ref l :: <com.milowski.monos.monomial.LexOrderedList>)
      (invoke l 'getLexOrder))

(define (lexed-list->list l :: <com.milowski.monos.monomial.LexOrderedList>)
   (java-list->list l))


(define (lexed-list-ref l :: <com.milowski.monos.monomial.LexOrderedList> i)
   (java.util.List:get l i))

(define (lexed-list-remove! l :: <com.milowski.monos.monomial.LexOrderedList> i :: <integer>)
   (java.util.List:remove l i))

(define (lexed-list-length l :: <com.milowski.monos.monomial.LexOrderedList>)
   (java.util.List:size l))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Monomial Ideals
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax monomial-ideal
   (syntax-rules (*lex-order*)
      ((monomial-ideal m ...)
       (construct-monomial-ideal *lex-order* `(m ...))) ))

;;(define-syntax monomial-ideal-with-order
;;   (syntax-rules ()
;;      ((monomial-ideal-with-order order m ...)
;;       (fluid-let ((*lex-order* order))
;;          (construct-monomial-ideal order `(m ...))) ) ))

(define-syntax monomial-ideal-with-order
   (syntax-rules ()
      ((monomial-ideal-with-order order m ...)
          (construct-monomial-ideal order `(m ...))) ) )

(define (copy-monomial-ideal ideal :: <com.milowski.monos.monomial.MonomialIdeal> #!key (deep #f))
   (let ((copy (com.milowski.monos.monomial.MonomialIdeal:new (lex-order-ref ideal))))
      (if deep
         (lexed-list-for-each 
             (lambda (m :: <com.milowski.monos.monomial.Monomial>) 
                 (invoke copy 'add (com.milowski.monos.monomial.Monomial:new (invoke m 'getValues))))
             ideal)
         (invoke copy 'addAll ideal))
      copy))

(define (list->monomial-ideal l)
   (let ((i (com.milowski.monos.monomial.MonomialIdeal:new *lex-order*)))
       (for-each (lambda (x) (java.util.List:add i (symbol->monomial *lex-order* x))) l) 
       i))

(define (construct-monomial-ideal order l)
   (let ((i (com.milowski.monos.monomial.MonomialIdeal:new order)))
       (for-each (lambda (x) (java.util.List:add i (symbol->monomial order x))) l) 
       i))

(define (decompose-ideal ideal :: <com.milowski.monos.monomial.MonomialIdeal> #!key (method `alex-dual) (direction #t))
    (if (eq? method `scarf-complex)
        (invoke-static <com.milowski.monos.monomial.IdealGenerator> 'scarfMethodDecompose ideal)
        (invoke-static <com.milowski.monos.monomial.IdealGenerator> 'decompose direction ideal)) )

(define (make-artinian ideal :: <com.milowski.monos.monomial.MonomialIdeal>)
   (invoke-static <com.milowski.monos.monomial.IdealGenerator> 'makeArtinian ideal))

(define (make-generic ideal :: <com.milowski.monos.monomial.MonomialIdeal>)
   (invoke-static <com.milowski.monos.monomial.IdealGenerator> 'makeGeneric ideal))

(define (find-facet ideal :: <com.milowski.monos.monomial.MonomialIdeal>)
   (invoke-static <com.milowski.monos.monomial.IdealGenerator> 'findFacet ideal))

(define (monomial-ideal->monomial-tree ideal :: <com.milowski.monos.monomial.MonomialIdeal>)
   (let ((tree (com.milowski.monos.monomial.MonomialTree:new (invoke ideal 'getLexOrder))))
      (invoke tree 'add ideal)
      tree))

(define (minimize-ideal ideal :: <com.milowski.monos.monomial.MonomialIdeal>)
   (let ((tree (monomial-ideal->monomial-tree ideal)))
      (minimize-tree tree)
      (monomial-tree->monomial-ideal tree)))

(define (lcm l :: <com.milowski.monos.monomial.MonomialIdeal>)
   (invoke-static <com.milowski.monos.monomial.IdealGenerator> 'lcm l))

(define (intersect . ideals)
   (if (null? ideals)
      (error "No set of ideals specified.")
      (let ((result (car ideals)))
         (for-each (lambda (i) (set! result (com.milowski.monos.monomial.IdealGenerator:intersect result i))) (cdr ideals))
         result)) )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Monomials
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax monomial
   (syntax-rules (*lex-order*)
       ((monomial order exp)
        (symbol->monomial order `exp))
       ((monomial exp)
        (symbol->monomial *lex-order* `exp))  ))

(define-syntax monomial->string
   (syntax-rules (*lex-order*)
      ((monomial->string order m)
       (format-monomial order m))
      ((monomial->string m)
       (format-monomial *lex-order* m)) ))

(define (format-monomial order m :: <com.milowski.monos.monomial.Monomial>)
       (invoke m 'format order))

(define (monomial-divides? first second :: <com.milowski.monos.monomial.Monomial>)
       (invoke second 'divides first))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Monomial Trees
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (project-tree tree :: <com.milowski.monos.monomial.MonomialTree>)
   (invoke tree 'project)
   tree)

(define (minimize-tree tree :: <com.milowski.monos.monomial.MonomialTree>)
   (invoke tree 'minimize)
   tree)

(define (monomial-tree->monomial-ideal tree :: <com.milowski.monos.monomial.MonomialTree>)
   (invoke tree 'getIdealGenerator))

(define (contains? tree :: <com.milowski.monos.monomial.MonomialTree> m :: <com.milowski.monos.monomial.Monomial>)
   (invoke tree 'contains m))

(define (monomial-tree->iterator tree :: <com.milowski.monos.monomial.MonomialTree>)
   (invoke tree 'iterator #t))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Binomials
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (list->compact-binomial . args)
   (if (null? args)
      (error "list->compact-binomial requires arguments")
      (let ((len (length args))
            (first (car args)))
         (if (and (= len 1) (list? first))
             (construct-compact-binomial first)
             (construct-compact-binomial args))) ) )

(define (leading-term b :: <com.milowski.monos.binomial.Binomial>)
   (invoke b 'toLeadingMonomial))

(define (trailing-term b :: <com.milowski.monos.binomial.Binomial>)
   (invoke b 'toTrailingMonomial))

(define-syntax binomial
   (syntax-rules (*lex-order*)
       ((binomial order l t)
        (symbol->binomial order `l `t))
       ((binomial l t)
        (symbol->binomial *lex-order* `l `t))  ))

(define-syntax binomial->string
   (syntax-rules (*lex-order*)
      ((binomial->string order b)
       (format-monomial order b))
      ((binomial->string b)
       (format-monomial *lex-order* b)) ))

(define (format-binomial order b :: <com.milowski.monos.binomial.Binomial>)
       (invoke b 'format order))

;; TODO: implement
;;(define (binomial-divides? first second :: <com.milowski.monos.monomial.Monomial>)
;;       (invoke second 'divides first))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Binomial Ideals
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(define-syntax binomial-ideal
   (syntax-rules (*lex-order*)
      ((binomial-ideal b ...)
       (construct-binomial-ideal *lex-order* `(b ...)) ) ))

(define-syntax binomial-ideal-with-order
   (syntax-rules ()
      ((binomial-ideal-with-order order b ...)
       (fluid-let ((*lex-order* order))
          (construct-binomial-ideal *lex-order* `(b ...)) )) ))

(define (construct-binomial-ideal order l)
   (let ((i (com.milowski.monos.binomial.BinomialIdeal:new order)))
       (for-each (lambda (x) (java.util.List:add i (apply symbol->binomial (cons order x)))) l) 
       i))

(define (read-matrix->binomial-ideal in :: <java.io.Reader>)
   (invoke-static <com.milowski.monos.binomial.MatrixBasis> 'readMatrixAsBinomials in #f #f #!null) )

(define (read-matrix in :: <java.io.Reader>)
   (invoke-static <com.milowski.monos.binomial.MatrixBasis> 'read in) )

(define (write-matrix obj out :: <java.io.Writer>)
   (if (instance? obj <com.milowski.monos.binomial.MatrixBasis>)
      (let ((m :: <com.milowski.monos.binomial.MatrixBasis> obj))
         (invoke m 'write out))
      (let ((ideal :: <com.milowski.monos.binomial.BinomialIdeal> obj))
         (invoke ideal 'writeAsMatrix out)) ) )
   



(define (binomial-groebner ideal :: <com.milowski.monos.binomial.BinomialIdeal> #!key (ordering 'grevlex) )
   (let ((basis (com.milowski.monos.binomial.GroebnerBasis:new (lex-order-ref ideal)))
         (morder (monomial-order ordering)) )
      (invoke basis 'setMonomialOrdering morder)
      (invoke basis 'computeFullBasis ideal)
      (invoke basis 'getBasis)))

(set! create-exponent-array (primitive-array-new <short>))
(set! set-exponent (primitive-array-set <short>))
(set! get-exponent (primitive-array-get <short>))
(define (exponent-array . l)
   (let* ((len (length l))
         (e (create-exponent-array len)))
      (do 
         ((i 0 (+ i 1)))
         ((= i len) e)
         (set-exponent e i (car l))
         (set! l (cdr l)) ) ))
(define (get-entry matrix :: <com.milowski.monos.binomial.MatrixBasis> row :: <int> col :: <int>)
   (invoke matrix 'get row col))

(define (matrix-kernel  matrix :: <com.milowski.monos.binomial.MatrixBasis>)
  (let ((kbasis (invoke-static <com.milowski.monos.binomial.KernelBasis> 'getInstance)))
     (invoke kbasis 'compute matrix)) )

(define (matrix->binomial-ideal matrix :: <com.milowski.monos.binomial.MatrixBasis>)
  (invoke matrix 'toBinomials #f)) 

(define (monomial-order sym)
   (case sym
     ('lex (static-field <com.milowski.monos.binomial.GroebnerBasis> 'LEXICOGRAPHIC))
     ('grevlex (static-field <com.milowski.monos.binomial.GroebnerBasis> 'DEGREE_REVERSE_LEXICOGRAPHIC))
     ('revlex (static-field <com.milowski.monos.binomial.GroebnerBasis> 'REVERSE_LEXICOGRAPHIC))
     (else sym)) )

(define (weighted-lexicographic-ordering weights :: <short[]>)
   (com.milowski.monos.binomial.GroebnerBasis.WeightedReverseLexicographicOrdering:new weights))

(define (toric-groebner matrix :: <com.milowski.monos.binomial.MatrixBasis> #!key (ordering 'grevlex) (row-space-vector '()))
   (let ((positive-row-vector :: <short[]>
          (if (null? row-space-vector)
            (let* ((rows (invoke matrix 'getRowCount))
                   (cols (invoke matrix 'getColumnCount))
                   (result (create-exponent-array cols)) )
              (do ((row 0 (+ row 1)))
                  ((= row rows) result)
                 (do ((col 0 (+ col 1)))
                    ((= col cols) #t)
                    (set-exponent result col (+ (get-exponent result col) 
                                                (get-entry matrix row col)) ) ) ) )
            row-space-vector ) )
         (morder (monomial-order ordering)) )
   (let* ((starter (matrix->binomial-ideal (matrix-kernel matrix)))
          (basis (com.milowski.monos.binomial.GroebnerBasis:new (lex-order-ref starter))))
      (invoke basis 'setMonomialOrdering morder)
      (invoke basis 'computeToricIdeal starter positive-row-vector)
      (invoke basis 'getBasis))) )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Scarf Complex
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (monomial-ideal->scarf-complex i :: <com.milowski.monos.monomial.MonomialIdeal>)
   (invoke-static <com.milowski.monos.monomial.IdealGenerator> 'makeGeneric i)
   (invoke-static <com.milowski.monos.monomial.IdealGenerator> 'makeArtinian i)
   (let ((complex (com.milowski.monos.monomial.ScarfComplex:new i)))
      (invoke complex 'getDecomposition (invoke-static <com.milowski.monos.monomial.IdealGenerator> 'findFacet i)) ))
 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; XML
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (parse-xml-from-port->document in :: <java.io.Reader> #!key base-uri)
   (let ((doc-loader (as <org.infoset.xml.sax.SAXDocumentLoader> (org.infoset.xml.sax.SAXDocumentLoader:new)) ))
     (if base-uri
         (let ((uri-value
                  (if (string? base-uri) (java.net.URI:new (string->symbol base-uri))
                                         base-uri)) )
             (invoke doc-loader 'load in (as <java.net.URI> uri-value)) )
         (invoke doc-loader 'load in)) ) )

(define (parse-xml-from-port in :: <java.io.Reader> dest :: <org.infoset.xml.ItemDestination> #!key base-uri)
   (let ((doc-loader (as <org.infoset.xml.sax.SAXDocumentLoader> (org.infoset.xml.sax.SAXDocumentLoader:new)) ))
     (if base-uri
         (let ((uri-value
                  (if (string? base-uri) (java.net.URI:new (string->symbol base-uri))
                                         base-uri)) )
             (invoke doc-loader 'generate in (as <java.net.URI> uri-value) dest) )
         (invoke doc-loader 'load in dest)) ) )

(define (parse-xml-from-uri uri dest)
   (let ((doc-loader (as <org.infoset.xml.sax.SAXDocumentLoader> (org.infoset.xml.sax.SAXDocumentLoader:new)) ))
      (let ((uri-value
               (if (string? uri) (java.net.URI:new (string->symbol uri))
                                 uri)) )
          (invoke doc-loader 'generate (as <java.net.URI> uri-value) dest) )))

(define (parse-xml-from-uri->document uri)
   (let ((doc-loader (as <org.infoset.xml.sax.SAXDocumentLoader> (org.infoset.xml.sax.SAXDocumentLoader:new)) ))
      (let ((uri-value
               (if (string? uri) (java.net.URI:new (string->symbol uri))
                                 uri)) )
          (invoke doc-loader 'load (as <java.net.URI> uri-value)) )))

(define (file->uri path :: <string>)
   (let ((f (java.io.File:new (string->symbol path))))
      (invoke f 'toURI)) )

(define (unmarshall obj :: <org.infoset.xml.Parent>)
  (if (instance? obj <org.infoset.xml.Document>)
      (com.milowski.monos.XML:unmarshall (as <org.infoset.xml.Document> obj))
      (com.milowski.monos.XML:unmarshall (as <org.infoset.xml.Element> obj))) )

(define (marshall obj :: <com.milowski.monos.XMLMarshaller> dest :: <org.infoset.xml.ItemDestination>)
  (invoke obj 'toXML dest))

(define (xml-writer output :: <java.io.Writer> #!key (encoding "utf-8"))
   (org.infoset.xml.util.WriterItemDestination:new output (string->symbol encoding)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Iterators
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (has-next iter :: <java.util.Iterator>)
   (invoke iter 'hasNext))

(define (next iter :: <java.util.Iterator>)
   (invoke iter 'next))

(define (remove iter :: <java.util.Iterator>)
   (invoke iter 'remove))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Misc
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (current-time-millis)
   (invoke-static <java.lang.System> 'currentTimeMillis))

(define (time-procedure proc . args)
   (let ((start (current-time-millis)))
      (apply proc args)
      (let* ((value (apply proc args))
             (elapsed (- (current-time-millis) start)))
         (display "Elapsed: ")
         (display elapsed)
         (newline)
         value) ) )

(set! timer-value 0)
(define (timer)
   (if (= timer-value 0)
      (set! timer-value (current-time-millis))
      (let* ((elapsed (- (current-time-millis) timer-value)))
         (set! timer-value 0)
         (display "Elapsed: ")
         (display elapsed)
         (newline) )) )

